home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / GRAPHICS.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  28.0 KB  |  910 lines
  1. ; GRAPHICS.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*    Borland Graphic Interface-Compatible Graphics Routines        *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: M. Vuilleumier        Date: Jun 1992            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22. (begin
  23.   (define set-distances!)          ; coordinates system functions
  24.   (define set-coordinates!)
  25.   (define set-point?-!)
  26.   (define set-world!)
  27.   (define restore-world!)
  28.  
  29.   (define close-graph)            ; control functions
  30.   (define detect-graph)
  31.   (define graph-defaults)
  32.   (define get-graph-mode)
  33.   (define get-mode-range)
  34.   (define init-graph)
  35.   (define install-user-driver)
  36.   (define install-user-font)
  37.   (define restore-crt-mode)
  38.   (define set-graph-mode)
  39.   (define set-write-mode)
  40.  
  41.   (define arc)                ; drawing functions
  42.   (define circle)
  43.   (define draw-poly)
  44.   (define ellipse)
  45.   (define get-arc-coords)
  46.   (define get-aspect-ratio)
  47.   (define get-line-settings)
  48.   (define line)
  49.   (define line-rel)
  50.   (define line-to)
  51.   (define move-to)
  52.   (define move-rel)
  53.   (define rectangle)
  54.   (define set-aspect-ratio)
  55.   (define set-line-style)
  56.  
  57.   (define bar)                ; filling functions
  58.   (define bar-3d)
  59.   (define fill-ellipse)
  60.   (define fill-poly)
  61.   (define flood-fill)
  62.   (define get-fill-pattern)
  63.   (define get-fill-settings)
  64.   (define pie-slice)
  65.   (define sector)
  66.   (define set-fill-pattern)
  67.   (define set-fill-style)
  68.  
  69.   (define clear-device)            ; windows functions
  70.   (define set-active-page)
  71.   (define set-visual-page)
  72.   (define clear-viewport)
  73.   (define get-view-settings)
  74.   (define set-viewport)
  75.   (define get-image)
  76.   (define image-size)
  77.   (define put-image)
  78.   (define get-pixel)
  79.   (define put-pixel)
  80.  
  81.   (define get-text-settings)        ; text .CHR functions
  82.   (define out-text)
  83.   (define out-text-xy)
  84.   (define set-text-justify)
  85.   (define set-text-style)
  86.   (define set-user-char-size)
  87.   (define text-size)
  88.  
  89.   (define get-bk-color)            ; palette & color functions
  90.   (define get-color)
  91.   (define get-default-palette)
  92.   (define get-max-color)
  93.   (define get-palette)
  94.   (define get-palette-size)
  95.   (define set-all-palette)
  96.   (define set-bk-color)
  97.   (define set-color)
  98.   (define set-palette)
  99.   (define set-rgb-palette)
  100.  
  101.   (define graph-error-msg)        ; miscellanous queries
  102.   (define graph-result)
  103.   (define get-driver-name)
  104.   (define get-max-mode)
  105.   (define get-max-xy)            ; (cons (get-max-x) (get-max-y))
  106.   (define get-mode-name)
  107.   (define get-xy)            ; (cons (get-x) (get-y))
  108.   )
  109.  
  110. ;---------------------------------------- symbolic parameters table
  111.  
  112. (define bgi-environment
  113.   (let* (
  114.    (driver-l  '((detect           . 0)
  115.         (cga           . 1)
  116.         (mcga           . 2)
  117.         (ega           . 3) 
  118.         (ega64           . 4)
  119.         (egamono        . 5)
  120.         (ibm8514        . 6)
  121.         (hercmono        . 7)
  122.         (att400        . 8)
  123.         (vga           . 9)
  124.         (pc3270        . 10)))
  125.  
  126.    (mode-l    '((cga-c0           . 0)    ; 320 x 200, 4 color
  127.         (cga-c1           . 1)    ; 320 x 200, 4 color
  128.         (cga-c2           . 2)    ; 320 x 200, 4 color
  129.         (cga-c3           . 3)    ; 320 x 200, 4 color
  130.         (cga-hi           . 4)    ; 640 X 200, 2 color
  131.  
  132.         (mcga-c0        . 0)    ; 320 X 200, 4 color
  133.         (mcga-c1        . 1)    ; 320 x 200, 4 color
  134.         (mcga-c2        . 2)    ; 320 x 200, 4 color
  135.         (mcga-c3        . 3)    ; 320 x 200, 4 color
  136.         (mcga-med        . 4)    ; 640 X 200, 2 color
  137.         (mcga-hi        . 5)    ; 640 X 480, 2 color
  138.  
  139.         (ega-lo           . 0)    ; 640 X 200, 16 color, 4 pages
  140.         (ega-hi           . 1)    ; 640 X 350, 16 color, 2 pages
  141.         (ega64-lo        . 0)    ; 640 X 200, 16 color
  142.         (ega64-hi        . 1)    ; 640 X 350, 16 color
  143.         (egamono-hi        . 3)    ; 640 X 350, 2 color, 2 pg if 256 Kb
  144.  
  145.         (vga-lo           . 0)    ; 640 X 200, 16 color, 2 pages
  146.         (vga-med        . 1)    ; 640 X 350, 16 color, 2 pages
  147.         (vga-hi           . 2)    ; 640 X 480, 16 color
  148.  
  149.         (att400-c0        . 0)    ; 320 X 200, 4 color
  150.         (att400-c1        . 1)    ; 320 x 200, 4 color
  151.         (att400-c2        . 2)    ; 320 x 200, 4 color
  152.         (att400-c3        . 3)    ; 320 x 200, 4 color
  153.         (att400-med        . 4)    ; 640 X 200, 2 color
  154.         (att400-hi        . 5)    ; 640 X 400, 2 color
  155.  
  156.         (hercmono-hi        . 0)    ; 720 X 348, 2 color, 2 pages
  157.         (pc3270-hi        . 0) ; 720 X 350, 2 color
  158.         (ibm8514-lo        . 0) ; 1024 X 768, 256 color
  159.         (ibm8514-hi        . 1))); 640 X 480, 256 color
  160.  
  161.    (wmode-l   '((copy            . 0)
  162.         (xor            . 1)))
  163.  
  164.    (pmode-l (append wmode-l 
  165.           '((or           . 2)
  166.         (and            . 3)
  167.         (not            . 4))))
  168.  
  169.    (line-l    '((solid            . 0)
  170.         (dotted         . 1)
  171.         (center         . 2)
  172.         (dashed         . 3)
  173.         (user-bit        . 4)))
  174.  
  175.    (width-l   '((normal          . 1)
  176.         (thick         . 3)))
  177.  
  178.    (fill-l    '((empty          . 0)    ; all background color
  179.         (solid          . 1)    ; all fill color
  180.         (line           . 2) ; continuous -------
  181.         (ltslash        . 3) ; light ///////
  182.         (slash          . 4) ; thick    ///////
  183.         (bkslash        . 5)    ; thick \\\\\\\
  184.         (ltbkslash       . 6) ; light \\\\\\\
  185.         (hatch          . 7) ; hatch [][][][]
  186.         (xhatch         . 8)    ; X-hatch XXXXXXX
  187.         (interleave       . 9)    ; lines -_-_-_-_-_
  188.         (wide-dot        . 10); dots . . . . . .
  189.         (close-dot         . 11); dots ...........
  190.         (user-fill           . 12)))
  191.  
  192.    (horiz-l   '((left           . 0)
  193.         (center         . 1)
  194.         (right          . 2)))
  195.  
  196.    (vert-l    '((bottom         . 0)
  197.         (center         . 1)
  198.         (top            . 2)))
  199.  
  200.    (direct-l  '((horiz           . 0)
  201.         (vert            . 1)))
  202.  
  203.    (font-l    '((default        . 0)
  204.         (triplex        . 1)
  205.         (small          . 2)
  206.         (sans-serif       . 3)
  207.         (gothic         . 4)
  208.         (script         . 5)
  209.         (simplex        . 6)
  210.         (triplex-scr       . 7)
  211.         (complex        . 8)
  212.         (european        . 9)
  213.         (bold           . 10)))
  214.  
  215.    (color-l   '((black            . 0)
  216.         (blue            . 1)
  217.         (green            . 2)
  218.         (cyan            . 3)
  219.         (red            . 4)
  220.         (magenta        . 5)
  221.         (brown            . 6)
  222.         (light-gray        . 7)
  223.         (dark-gray        . 8)
  224.         (light-blue        . 9)
  225.         (light-green        . 10)
  226.         (light-cyan        . 11)
  227.         (light-red        . 12)
  228.         (light-magenta        . 13)
  229.         (yellow        . 14)
  230.         (white            . 15)
  231.  
  232.         (ega-black        . 0)
  233.         (ega-blue        . 1)
  234.         (ega-green        . 2)
  235.         (ega-cyan        . 3)
  236.         (ega-red        . 4)
  237.         (ega-magenta        . 5)
  238.         (ega-light-gray    . 7)
  239.         (ega-brown        . 20)
  240.         (ega-dark-gray        . 56)
  241.         (ega-light-blue    . 57) 
  242.         (ega-light-green   . 58)
  243.         (ega-light-cyan    . 59)
  244.         (ega-light-red        . 60)
  245.         (ega-light-magenta . 61)
  246.         (ega-yellow        . 62)
  247.         (ega-white        . 63)
  248.  
  249.         (background       . 0)
  250.         (cga-light-green   . 1)
  251.         (cga-light-red        . 2)
  252.         (cga-yellow        . 3)
  253.         (cga-light-cyan    . 1)
  254.         (cga-light-magenta . 2)
  255.         (cga-white        . 3)
  256.         (cga-green        . 1) 
  257.         (cga-red        . 2)
  258.         (cga-brown        . 3)
  259.         (cga-cyan        . 1)
  260.         (cga-magenta        . 2)
  261.         (cga-light-gray    . 3))))
  262.  (the-environment)))
  263.  
  264. ;---------------------------------------- main function dispatcher
  265.  
  266. (syntax (code it l) (locate it (access l bgi-environment)))
  267. (syntax (decode it l) (assq-r it (access l bgi-environment)))
  268. (syntax (control x) (+ x 0))
  269. (syntax (drawing x) (+ x 20))
  270. (syntax (filling x) (+ x 40))
  271. (syntax (windows x) (+ x 60))
  272. (syntax (textchr x) (+ x 80))
  273. (syntax (palette x) (+ x 100))
  274. (syntax (queries x) (+ x 120))
  275.  
  276. (letrec
  277.   ((bgi-origin
  278.      (lambda proc-ctrl
  279.        (set! (access *pcs-graphics-error* user-global-environment) proc-ctrl)))
  280.  
  281. ;---------------------------------------- parameters checking tools
  282.  
  283.    (point?
  284.      (lambda (arg)
  285.        (if (pair? arg)
  286.        (and (number? (car arg))
  287.         (number? (cdr arg))))))
  288.  
  289.    (point-int?
  290.      (lambda (arg)
  291.        (if (pair? arg)
  292.        (and (integer? (car arg))
  293.         (integer? (cdr arg))))))
  294.  
  295.    (testargs
  296.      (lambda arglist
  297.        (if (pair? arglist)
  298.           (if ((caar arglist) (cdar arglist))
  299.               (apply testargs (cdr arglist))
  300.               (%error-invalid-operand (car *pcs-graphics-error*) (cdar arglist))))))
  301.  
  302.    (%proc
  303.      (lambda (clos)
  304.        (cons closure? clos)))
  305.  
  306.    (%int
  307.      (lambda (integer)
  308.        (cons integer? integer)))
  309.  
  310.    (%num
  311.      (lambda (number)
  312.        (cons number? number)))
  313.  
  314.    (%str
  315.      (lambda (string)
  316.        (cons string? string)))
  317.  
  318.    (%bool
  319.      (lambda (boolint)
  320.        (cons 
  321.          (lambda (arg)
  322.            (or (eq? arg 0)
  323.            (eq? arg 1)))
  324.      boolint)))
  325.  
  326.    (%point
  327.      (lambda (pair)
  328.        (cons point? pair)))
  329.  
  330.    (%disp %point)
  331.  
  332.    (%poly
  333.      (lambda (poly)
  334.        (cons
  335.          (named-lambda (poly? poly)
  336.            (or (null? poly)
  337.            (if (pair? poly)
  338.            (and (point? (car poly))
  339.                 (poly? (cdr poly))))))
  340.      poly)))
  341.  
  342.    (%int-list
  343.      (lambda (palett)
  344.        (cons
  345.          (named-lambda (palette? palett)
  346.        (or (null? palett)
  347.            (if (pair? palett)
  348.            (and (integer? (car palett))
  349.                 (palette? (cdr palett))))))
  350.      palett)))
  351.  
  352.    (%symb-borne
  353.      (lambda (item . borne)
  354.        (cons
  355.      (lambda (item)
  356.        (or (not (integer? item))
  357.            (and (>= item 0)
  358.             (or (null? borne)
  359.             (<= item (car borne))))))
  360.      item)))
  361.  
  362.    (locate
  363.      (lambda (item list)
  364.        (if (integer? item)
  365.        item
  366.        (let ((found (assq item list)))
  367.          (if (null? found)
  368.          (%error-invalid-operand (car *pcs-graphics-error*) item)
  369.          (cdr found))))))
  370.  
  371.    (assq-r
  372.      (lambda (number list)
  373.     (if (not (null? list))
  374.           (if (eqv? number (cdar list))
  375.           (caar list)
  376.           (assq-r number (cdr list))))))
  377.  
  378. ;---------------------------------------- coordinate systems
  379.  
  380.    (x (lambda (p) (round (car p))))
  381.    (y (lambda (p) (round (cdr p))))
  382.  
  383.    (point (lambda (pair) (cons (x pair) (y pair))))
  384.  
  385.    (world-coord
  386.      (lambda (selector up-lt bt-rt)
  387.        (let* ((offset (selector up-lt))
  388.           (end (selector bt-rt))
  389.           (max (selector (%graphics (queries 4))))
  390.           (factor (/ max (- end offset))))
  391.          (lambda (point)
  392.        (round (* factor (- (selector point) offset)))))))
  393.  
  394.    (xy (lambda (x) x))
  395.  
  396.    (world-inverse
  397.      (lambda (up-lt bt-rt)
  398.        (let* ((xy-max (%graphics (queries 4)))
  399.           (x-offset (car up-lt))
  400.           (x-end (car bt-rt))
  401.           (x-factor (/ (- x-end x-offset) (car xy-max)))
  402.           (y-offset (cdr up-lt))
  403.           (y-end (cdr bt-rt))
  404.           (y-factor (/ (- y-end y-offset) (cdr xy-max))))
  405.      (lambda (point)
  406.        (cons (+ x-offset (* x-factor (car point)))
  407.          (+ y-offset (* y-factor (cdr point))))))))
  408.  
  409.    (dx (lambda (orig dist) (round (car dist))))
  410.    (dy (lambda (orig dist) (round (cdr dist))))
  411.  
  412.    (compute-distance
  413.      (lambda (pos-proc)
  414.        (lambda (orig dist)
  415.              (- (pos-proc (cons (+ (car orig) (car dist))
  416.                       (+ (cdr orig) (cdr dist))))
  417.              (pos-proc orig)))))
  418.  
  419.    (world-distance
  420.      (lambda (selector up-lt bt-rt)
  421.        (let* ((offset (selector up-lt))
  422.           (end (selector bt-rt))
  423.           (max (selector (%graphics (queries 4))))
  424.           (factor (/ max (- end offset))))
  425.          (lambda (orig dist)
  426.        (round (* factor (selector dist)))))))
  427.     
  428.    (du (lambda (orig dist) (round dist)))
  429.  
  430.    (compute-unary-distance
  431.      (lambda (pos-proc)
  432.        (lambda (orig dist)
  433.              (- (pos-proc (cons (+ (car orig) dist) (cdr orig)))
  434.              (pos-proc orig)))))
  435.  
  436.    (world-unary-distance
  437.      (lambda (selector up-lt bt-rt)
  438.        (let* ((offset (selector up-lt))
  439.           (end (selector bt-rt))
  440.           (max (selector (%graphics (queries 4))))
  441.           (factor (/ max (- end offset))))
  442.          (lambda (orig dist)
  443.        (round (* factor dist))))))
  444.     
  445.   )
  446.  
  447.   (set! (access *pcs-bgi-error* user-global-environment) ; link with DEBUGGER.S
  448.         (lambda ()
  449.           (%graphics (queries 0) (graph-result))))
  450.  
  451.  
  452.   (set! set-distances! (lambda (proc-x proc-y proc-un)    ; coord system
  453.     (bgi-origin 'set-distances! proc-x proc-y proc-un)
  454.     (testargs (%proc proc-x) (%proc proc-y) (%proc proc-un))
  455.     (let ((old (list dx dy du)))
  456.       (set! dx proc-x)
  457.       (set! dy proc-y)
  458.       (set! du proc-un)
  459.       old)))
  460.  
  461.   (set! set-coordinates! (lambda (proc-x proc-y proc-xy)
  462.     (bgi-origin 'set-coordinates! proc-x proc-y proc-xy)
  463.     (testargs (%proc proc-x) (%proc proc-y) (%proc proc-xy))
  464.     (let ((old (list x y xy)))
  465.       (set! x proc-x)
  466.       (set! y proc-y)
  467.       (set! xy proc-xy)
  468.       (append old
  469.           (set-distances! (compute-distance proc-x)
  470.                       (compute-distance proc-y)
  471.                   (compute-unary-distance proc-x))))))
  472.  
  473.   (set! set-point?-! (lambda (proc)
  474.     (bgi-origin 'set-point?-! proc)
  475.     (testargs (%proc proc))
  476.     (let ((old point?))
  477.       (set! point? proc)
  478.       old)))
  479.  
  480.   (set! set-world! (lambda (up-lt bt-rt)
  481.     (bgi-origin 'set-world! up-lt bt-rt)
  482.     (testargs (%point up-lt) (%point bt-rt))
  483.     (let ((oldp (set-point?-! point?))
  484.           (oldc (set-coordinates! (world-coord car up-lt bt-rt)
  485.                       (world-coord cdr up-lt bt-rt)
  486.                       (world-inverse up-lt bt-rt)))
  487.           (oldd (set-distances! (world-distance car up-lt bt-rt)
  488.                     (world-distance cdr up-lt bt-rt)
  489.                     (world-unary-distance car up-lt bt-rt))))
  490.       (set-cdr! (cddr oldc) '())
  491.       (append (cons oldp oldc) oldd))))
  492.  
  493.   (set! restore-world! (lambda (procs)
  494.     (bgi-origin 'restore-world! procs)
  495.         (let* ((old (list point? x y xy dx dy du))
  496.            (up? (car procs)) (pos (cdr procs)) (dist (cddddr procs))
  497.            (ux  (car pos))   (uy  (cadr pos))  (uxy  (caddr pos))
  498.            (udx (car dist))  (udy (cadr dist)) (udu  (caddr dist)))
  499.        (testargs (%proc up?) (%proc ux) (%proc uy) (%proc uxy)
  500.                 (%proc udx) (%proc udy) (%proc udu))
  501.       (set! point? up?)
  502.       (set! x ux)
  503.       (set! y uy)
  504.       (set! xy uxy)
  505.       (set! dx udx)
  506.       (set! dy udy)
  507.       (set! du udu)
  508.       old)))
  509.  
  510.  
  511. ;---------------------------------------- BGI primitives
  512.  
  513.   (set! close-graph (lambda ()                ; control
  514.         (bgi-origin 'close-graph)
  515.         (%graphics (control 0))
  516.     (full-screen)))
  517.  
  518.   (set! detect-graph (lambda ()
  519.         (bgi-origin 'detect-graph)
  520.         (let ((drm (%graphics (control 1))))
  521.       (cons (decode (car drm) driver-l) (cdr drm)))))
  522.  
  523.   (set! graph-defaults (lambda ()
  524.         (bgi-origin 'graph-defaults)
  525.         (%graphics (control 2))))
  526.  
  527.   (set! get-graph-mode (lambda ()
  528.         (bgi-origin 'get-graph-mode)
  529.         (%graphics (control 3))))
  530.  
  531.   (set! get-mode-range (lambda arg
  532.     (let ((drv (if (null? arg) -1 (car arg))))
  533.           (bgi-origin 'get-mode-range drv)
  534.           (testargs (%symb-borne (if (number? drv) (abs drv) drv)))
  535.           (%graphics (control 4) (code drv driver-l)))))
  536.  
  537.   (set! init-graph (lambda args
  538.         (let ((drv (if (null? args) 0 (car args)))
  539.               (mode (if (null? (cdr args)) 0 (cadr args)))
  540.               (path (if (null? (cddr args)) (%system-file-name "") (caddr args))))
  541.           (bgi-origin 'init-graph drv mode path)
  542.           (testargs (%symb-borne drv) (%symb-borne mode) (%str path))
  543.           (%graphics (control 5) (code drv driver-l) (code mode mode-l) path)
  544.       (split-screen 4))))
  545.  
  546.   (set! install-user-driver (lambda (name)
  547.         (bgi-origin 'install-user-driver name)
  548.         (testargs (%str name))
  549.         (set! (access driver-l bgi-environment)
  550.           (cons (cons (string->symbol name)
  551.               (%graphics (control 6) name))
  552.             (access driver-l bgi-environment)))
  553.     (string->symbol name)))
  554.  
  555.   (set! install-user-font (lambda (name)
  556.         (bgi-origin 'install-user-font name)
  557.         (testargs (%str name))
  558.         (set! (access font-l bgi-environment)
  559.           (cons (cons (string->symbol name)
  560.               (%graphics (control 7) name))
  561.             (access font-l bgi-environment)))
  562.     (string->symbol name)))
  563.  
  564.  
  565.   (set! restore-crt-mode (lambda ()
  566.         (bgi-origin 'restore-crt-mode)
  567.         (%graphics (control 8))
  568.     (full-screen)))
  569.  
  570.   (set! set-graph-mode (lambda arg
  571.     (let ((mode (if (null? arg) (get-graph-mode) (car arg))))
  572.           (bgi-origin 'set-graph-mode mode)
  573.           (testargs (%symb-borne mode))
  574.           (%graphics (control 9) (code mode mode-l))
  575.       (split-screen 4))))
  576.  
  577.   (set! set-write-mode (lambda (mode)
  578.         (bgi-origin 'set-write-mode mode)
  579.     (testargs (%symb-borne mode 1))
  580.     (%graphics (control 10) (code mode wmode-l))))
  581.  
  582.  
  583.   (set! arc (lambda (pt st-angle end-angle radius)    ; drawing
  584.         (bgi-origin 'arc pt st-angle end-angle radius)
  585.     (testargs (%point pt) (%int st-angle) (%int end-angle) (%num radius))
  586.         (map xy (%graphics (drawing 0) (x pt) (y pt) st-angle end-angle 
  587.                    (abs (du pt radius))))))
  588.  
  589.   (set! circle (lambda (pt radius)
  590.         (bgi-origin 'circle pt radius)
  591.     (testargs (%point pt) (%num radius))
  592.         (%graphics (drawing 1) (x pt) (y pt) (abs (du pt radius)))))
  593.  
  594.   (set! draw-poly (lambda (point-list)
  595.         (bgi-origin 'draw-poly point-list)
  596.     (testargs (%poly point-list))
  597.         (%graphics (drawing 2) (map point point-list))))
  598.  
  599.   (set! ellipse (lambda (pt st-angle end-angle radius)
  600.         (bgi-origin 'ellipse pt st-angle end-angle radius)
  601.     (testargs (%point pt) (%int st-angle) (%int end-angle) (%disp radius))
  602.         (map xy (%graphics (drawing 3) (x pt) (y pt) st-angle end-angle
  603.                    (abs (dx pt radius)) (abs (dy pt radius))))))
  604.  
  605.   (set! get-arc-coords (lambda ()
  606.         (bgi-origin 'get-arc-coords)
  607.         (map xy (%graphics (drawing 4)))))
  608.  
  609.   (set! get-aspect-ratio (lambda ()
  610.         (bgi-origin 'get-aspect-ratio)
  611.         (%graphics (drawing 5))))
  612.  
  613.   (set! get-line-settings (lambda ()
  614.         (bgi-origin 'get-line-settings)
  615.         (let ((spw (%graphics (drawing 6))))
  616.       (list (decode (car spw) line-l) (cadr spw) 
  617.         (decode (caddr spw) width-l)))))
  618.  
  619.   (set! line (lambda (src-pt dest-pt)
  620.         (bgi-origin 'line src-pt dest-pt)
  621.     (testargs (%point src-pt) (%point dest-pt))
  622.         (%graphics (drawing 7) (x src-pt) (y src-pt) (x dest-pt) (y dest-pt))))
  623.  
  624.   (set! line-rel (lambda (disp)
  625.         (bgi-origin 'line-rel disp)
  626.     (testargs (%point disp)) 
  627.     (let ((pt (xy (%graphics (queries 6)))))
  628.       (%graphics (drawing 8) (dx pt disp) (dy pt disp)))))
  629.  
  630.   (set! line-to (lambda (dest-pt)
  631.         (bgi-origin 'line-to dest-pt)
  632.     (testargs (%point dest-pt))
  633.         (%graphics (drawing 9) (x dest-pt) (y dest-pt))))
  634.  
  635.   (set! move-to (lambda (dest-pt)
  636.         (bgi-origin 'move-to dest-pt)
  637.     (testargs (%point dest-pt))
  638.         (%graphics (drawing 10) (x dest-pt) (y dest-pt))))
  639.  
  640.   (set! move-rel (lambda (disp)
  641.         (bgi-origin 'move-rel disp)
  642.     (testargs (%disp disp))
  643.     (let ((pt (xy (%graphics (queries 6)))))
  644.           (%graphics (drawing 11) (dx pt disp) (dy pt disp)))))
  645.  
  646.   (set! rectangle (lambda (up-lt bt-rt)
  647.         (bgi-origin 'rectangle up-lt bt-rt)
  648.     (testargs (%point up-lt) (%point bt-rt))
  649.         (%graphics (drawing 12) (x up-lt) (y up-lt) (x bt-rt) (y bt-rt))))
  650.  
  651.   (set! set-aspect-ratio (lambda (fact-y)
  652.         (bgi-origin 'set-aspect-ratio fact-y)
  653.     (testargs (cons point-int? fact-y))
  654.         (%graphics (drawing 13) (car fact-y) (cdr fact-y))))
  655.  
  656.   (set! set-line-style (lambda (style upattern thickness)
  657.         (bgi-origin 'set-line-style style upattern thickness)
  658.     (testargs (%symb-borne style 4) (%int upattern) (%symb-borne thickness 3))
  659.         (%graphics (drawing 14) (code style line-l) upattern (code thickness width-l))))
  660.  
  661.  
  662.   (set! bar (lambda (up-lt bt-rt)            ; filling
  663.         (bgi-origin 'bar up-lt bt-rt)
  664.         (testargs (%point up-lt) (%point bt-rt))
  665.         (%graphics (filling 0) (x up-lt) (y up-lt) (x bt-rt) (y bt-rt))))
  666.  
  667.   (set! bar-3d (lambda (up-lt bt-rt depth top)
  668.         (bgi-origin 'bar-3d up-lt bt-rt depth top)
  669.     (let ((top (if (number? top) top (if top 1 0))))
  670.           (testargs (%point up-lt) (%point bt-rt) (%int depth) (%bool top))
  671.           (%graphics (filling 1) (x up-lt) (y up-lt) (x bt-rt) (y bt-rt) 
  672.                 (x (cons depth depth)) top))))
  673.  
  674.   (set! fill-ellipse (lambda (pt radius)
  675.         (bgi-origin 'fill-ellipse pt radius)
  676.         (testargs (%point pt) (%disp radius))
  677.         (%graphics (filling 2) (x pt) (y pt)
  678.            (abs (dx pt radius)) (abs (dy pt radius)))))
  679.  
  680.   (set! fill-poly (lambda (point-list)
  681.         (bgi-origin 'fill-poly point-list)
  682.         (testargs (%poly point-list))
  683.         (%graphics (filling 3) (map point point-list))))
  684.  
  685.   (set! flood-fill (lambda (pt border)
  686.         (bgi-origin 'flood-fill pt border)
  687.         (testargs (%point pt) (%int border))
  688.         (%graphics (filling 4) (x pt) (y pt) border)))
  689.  
  690.   (set! get-fill-pattern (lambda ()
  691.         (bgi-origin 'get-fill-pattern)
  692.         (%graphics (filling 5))))
  693.  
  694.   (set! get-fill-settings (lambda ()
  695.         (bgi-origin 'get-fill-settings)
  696.         (let ((sc (%graphics (filling 6))))
  697.       (cons (decode (car sc) fill-l) (cdr sc)))))
  698.  
  699.   (set! pie-slice (lambda (pt st-angle end-angle radius)
  700.         (bgi-origin 'pie-slice pt st-angle end-angle radius)
  701.         (testargs (%point pt) (%int st-angle) (%int end-angle) (%num radius))
  702.         (%graphics (filling 7) (x pt) (y pt) st-angle end-angle 
  703.                    (abs (du pt radius)))))
  704.  
  705.   (set! sector (lambda (pt st-angle end-angle radius)
  706.         (bgi-origin 'sector pt st-angle end-angle radius)
  707.         (testargs (%point pt) (%int st-angle) (%int end-angle) (%disp radius))
  708.         (%graphics (filling 8) (x pt) (y pt) st-angle end-angle
  709.                    (abs (dx pt radius)) (abs (dy pt radius)))))
  710.  
  711.   (set! set-fill-pattern (lambda (upattern color)
  712.         (bgi-origin 'set-fill-pattern upattern color)
  713.         (testargs (%int-list upattern) (%symb-borne color))
  714.         (%graphics (filling 9) upattern (code color color-l))))
  715.  
  716.   (set! set-fill-style (lambda (pattern color)
  717.         (bgi-origin 'set-fill-style pattern color)
  718.         (testargs (%symb-borne pattern 12) (%symb-borne color))
  719.         (%graphics (filling 10) (code pattern fill-l) (code color color-l))))
  720.  
  721.  
  722.   (set! clear-device (lambda ()         ; windows
  723.         (bgi-origin 'clear-device)
  724.         (%graphics (windows 0))))
  725.  
  726.   (set! set-active-page (lambda (page)
  727.         (bgi-origin 'set-active-page page)
  728.         (testargs (%int page))
  729.         (%graphics (windows 1) page)))
  730.  
  731.   (set! set-visual-page (lambda (page)
  732.         (bgi-origin 'set-visual-page page)
  733.         (testargs (%int page))
  734.         (%graphics (windows 2) page)))
  735.  
  736.   (set! clear-viewport (lambda ()
  737.         (bgi-origin 'clear-viewport)
  738.         (%graphics (windows 3))))
  739.  
  740.   (set! get-view-settings (lambda ()
  741.         (bgi-origin 'get-view-settings)
  742.         (let ((resu (%graphics (windows 4))))
  743.       (list (xy (car resu))    (xy (cadr resu)) (caddr resu)))))
  744.  
  745.   (set! set-viewport (lambda (up-lt bt-rt clip)
  746.         (bgi-origin 'set-viewport up-lt bt-rt clip)
  747.     (let ((clip (if (number? clip) clip (if clip 1 0))))
  748.           (testargs (%point up-lt) (%point bt-rt) (%bool clip))
  749.           (%graphics (windows 5) (x up-lt) (y up-lt) (x bt-rt) (y bt-rt) clip))))
  750.  
  751.   (set! get-image (lambda (up-lt bt-rt)
  752.         (bgi-origin 'get-image up-lt bt-rt)
  753.         (testargs (%point up-lt) (%point bt-rt))
  754.         (%graphics (windows 6) (x up-lt) (y up-lt) (x bt-rt) (y bt-rt))))
  755.  
  756.   (set! image-size (lambda (up-lt bt-rt)
  757.         (bgi-origin 'image-size up-lt bt-rt)
  758.         (testargs (%point up-lt) (%point bt-rt))
  759.         (%graphics (windows 7) (x up-lt) (y up-lt) (x bt-rt) (y bt-rt))))
  760.  
  761.   (set! put-image (lambda (pt image mode)
  762.         (bgi-origin 'put-image pt image mode)
  763.         (testargs (%point pt) (%str image) (%symb-borne mode 4))
  764.         (%graphics (windows 8) (x pt) (y pt) image (code mode pmode-l))))
  765.  
  766.   (set! get-pixel (lambda (pt)
  767.         (bgi-origin 'get-pixel pt)
  768.         (testargs (%point pt))
  769.         (%graphics (windows 9) (x pt) (y pt))))
  770.  
  771.   (set! put-pixel (lambda (pt color)
  772.         (bgi-origin 'put-pixel pt color)
  773.         (testargs (%point pt) (%symb-borne color))
  774.         (%graphics (windows 10) (x pt) (y pt) (code color color-l))))
  775.  
  776.  
  777.   (set! get-text-settings (lambda ()        ; text .CHR
  778.         (bgi-origin 'get-text-settings)
  779.         (let ((fdshv (%graphics (textchr 0))))
  780.       (list (decode (car fdshv) font-l)
  781.         (decode (cadr fdshv) direct-l) (caddr fdshv)
  782.         (decode (cadddr fdshv) horiz-l)
  783.         (decode (caddr (cddr fdshv)) vert-l)))))
  784.  
  785.   (set! out-text (lambda (string)
  786.         (bgi-origin 'out-text string)
  787.         (testargs (%str string))
  788.         (%graphics (textchr 1) string)))
  789.  
  790.   (set! out-text-xy (lambda (pt string)
  791.         (bgi-origin 'out-text-xy pt string)
  792.         (testargs (%point pt) (%str string))
  793.         (%graphics (textchr 2) (x pt) (y pt) string)))
  794.  
  795.   (set! set-text-justify (lambda (horiz vert)
  796.         (bgi-origin 'set-text-justify horiz vert)
  797.         (testargs (%symb-borne horiz 2) (%symb-borne vert 2))
  798.         (%graphics (textchr 3) (code horiz horiz-l) (code vert vert-l))))
  799.  
  800.   (set! set-text-style (lambda (font dir size)
  801.         (bgi-origin 'set-text-style font dir size)
  802.         (testargs (%symb-borne font) (%symb-borne dir 1) (%int size))
  803.         (%graphics (textchr 4) (code font font-l) (code dir direct-l) size)))
  804.  
  805.   (set! set-user-char-size (lambda (fact-x fact-y)
  806.         (bgi-origin 'set-user-char-size fact-x fact-y)
  807.         (testargs (cons point-int? fact-x) (cons point-int? fact-y))
  808.         (%graphics (textchr 5) (car fact-x) (cdr fact-x)
  809.                    (car fact-y) (cdr fact-y))))
  810.  
  811.   (set! text-size (lambda (string)
  812.         (bgi-origin 'text-size string)
  813.         (testargs (%str string))
  814.     (let* ((pnpos (%graphics (queries 6)))
  815.            (pnnew (cons (+ (car pnpos) (%graphics (textchr 7) string))
  816.                 (+ (cdr pnpos) (%graphics (textchr 6) string)))))
  817.       (cons (- (car (xy pnnew)) (car (xy pnpos)))
  818.         (- (cdr (xy pnnew)) (cdr (xy pnpos)))))))
  819.  
  820.   (set! get-bk-color (lambda ()        ; palette & color
  821.         (bgi-origin 'get-bk-color)
  822.         (%graphics (palette 0))))
  823.  
  824.   (set! get-color (lambda ()
  825.         (bgi-origin 'get-color)
  826.         (%graphics (palette 1))))
  827.  
  828.   (set! get-default-palette (lambda ()
  829.         (bgi-origin 'get-default-palette)
  830.         (%graphics (palette 2))))
  831.  
  832.   (set! get-max-color (lambda ()
  833.         (bgi-origin 'get-max-color)
  834.         (%graphics (palette 3))))
  835.  
  836.   (set! get-palette (lambda ()
  837.         (bgi-origin 'get-palette)
  838.         (%graphics (palette 4))))
  839.  
  840.   (set! get-palette-size (lambda ()
  841.         (bgi-origin 'get-palette-size)
  842.         (%graphics (palette 5))))
  843.  
  844.   (set! set-all-palette (lambda (palett)
  845.         (bgi-origin 'set-all-palette palett)
  846.         (testargs (%int-list palett))
  847.         (%graphics (palette 6) palett)))
  848.  
  849.   (set! set-bk-color (lambda (color)
  850.         (bgi-origin 'set-bk-color color)
  851.         (testargs (%symb-borne color))
  852.         (%graphics (palette 7) (code color color-l))))
  853.  
  854.   (set! set-color (lambda (color)
  855.         (bgi-origin 'set-color color)
  856.         (testargs (%symb-borne color))
  857.         (%graphics (palette 8) (code color color-l))))
  858.  
  859.   (set! set-palette (lambda (entry color)
  860.         (bgi-origin 'set-palette entry color)
  861.         (testargs (%symb-borne entry) (%symb-borne color))
  862.         (%graphics (palette 9) (code entry color-l) (code color color-l))))
  863.  
  864.   (set! set-rgb-palette (lambda (entry red green blue)
  865.         (bgi-origin 'set-rgb-palette entry red green blue)
  866.         (testargs (%symb-borne entry) (%int red) (%int green) (%int blue))
  867.         (%graphics (palette 10) (code entry color-l) red green blue)))
  868.  
  869.  
  870.   (set! graph-error-msg (lambda (id)        ; miscellanous queries
  871.         (bgi-origin 'graph-error-msg id)
  872.         (testargs (%int id))
  873.         (%graphics (queries 0) id)))
  874.  
  875.   (set! graph-result (lambda ()
  876.         (%graphics (queries 1))))
  877.  
  878.   (set! get-driver-name (lambda ()
  879.         (bgi-origin 'get-driver-name)
  880.         (%graphics (queries 2))))
  881.  
  882.   (set! get-max-mode (lambda ()
  883.         (bgi-origin 'get-max-mode)
  884.         (%graphics (queries 3))))
  885.  
  886.   (set! get-max-xy (lambda ()
  887.         (bgi-origin 'get-max-xy)
  888.         (%graphics (queries 4))))
  889.  
  890.   (set! get-mode-name (lambda (mode)
  891.         (bgi-origin 'get-mode-name mode)
  892.         (testargs (%symb-borne mode))
  893.         (%graphics (queries 5) (code mode mode-l))))
  894.  
  895.   (set! get-xy (lambda ()         
  896.         (bgi-origin 'get-xy)
  897.         (xy (%graphics (queries 6)))))
  898. )
  899.  
  900. ;-----
  901.  
  902. (macro code '())
  903. (macro control '())
  904. (macro drawing '())
  905. (macro filling '())
  906. (macro windows '())
  907. (macro textchr '())
  908. (macro palette '())
  909. (macro queries '())
  910.